Shareware Grab Bag/Shareware Grab Bag.iso/050/pulldown.arc/PULLDOWN.PAS

Pascal/Delphi Source File | 1984-11-12 | 10.3 KB | 584 lines

{ R+}
Program PullDownMenus;
{

Pull Down Menus in Turbo Pascal

      by

  Kurt M. Gutzmann



This is a set of routines for constructing a Xerox style
cum Macintosh user interface for Turbo Pascal programs.

Menus are loaded from a menu data file at start up.

The procedure RunMenus is a skeleton with a CASE statement
filled by the programmer to drive his particular menu
tree.

A sample menu data file and a fleshing out of the RunMenus
procedure is done here as an example of how to use PullDowns.

}



const

       MaxItems=10; {Max Items on a Menu Bar}
       MaxMenus=10; {Max Menus}
       Width=11;    {Width of Pull Down Fields}

Type

   VideoMode =(Norm,Rev,Hi,Und,RevHi,Blink,BlinkHi,RevBlink,RevBlinkHi);
   MaxString = String[255];
   stringW = string[Width];


   ProtoMenu = record
           NumEntry :array[0..MaxItems] of integer;
           Menu:array[0..MaxItems] of array[0..MaxItems] of stringW;
           MenuName:stringW;
           NoItems:integer;
           end;

   MenuPtr = ^ProtoMenu;

   MenuAry =  array[1..MaxMenus] of MenuPtr;

var

NumMenus:integer;
Menus:MenuAry;
exit:boolean;
VideoSeg:integer;{points to $B000 or $B800  for color or mono}
botbox:maxstring;


function ColorMonitor:boolean;
{returns TRUE if a Color monitor is installed}
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
   al:integer;
begin
regs.ax:=15 shl 8;
intr($10,regs);
al:=Lo(regs.ax);
if al=$7 then ColorMonitor:=false else ColorMonitor:=true;
end;


Procedure SetVideoSeg;
begin
if colormonitor then VideoSeg:=$B800 else VideoSeg:=$B000
end;


Procedure SetCursor(HiScan,LowScan:byte);
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
begin
regs.ax:=1 shl 8;
regs.cx:=HiScan shl 8 + LowScan;
intr($10,regs);
end;


Procedure CursorNormal;
begin
if ColorMonitor then SetCursor(6,7) else  SetCursor(10,11);
end;


Procedure CursorBlock;
begin
if ColorMonitor then SetCursor(1,7) else  SetCursor(1,14);
end;


Procedure CursorOff;
begin
SetCursor(31,0);
end;




procedure GetKb(var chcode,extcode:integer);

(*Obtains the character and extended codes of a struck key. The codes are
 removed from the buffer. This procedure will wait for a keystrike if the
 buffer is empty.*)

type
  RegPack = record
          ax,bx,cx,dx,di,si,ds,es,flags : integer;
        end;
var
  regs:RegPack;

begin
  regs.ax := $0000;
  intr($16,regs);
  extcode := regs.ax shr 8;   ; (*extended code is AH*)
  chcode := regs.ax and $00FF;    (*character code is AL*)
end;


function inchar(var ch:char;var ex:integer):boolean;{true if ASCII char}
{Returns char and extended code from keyboard}
var chcode,excode:integer;
begin
getkb(chcode,ex);
if chcode=0 then
    begin
    inchar:=false;
    ch:=chr(ex);
    end
else
    begin
    ch:=chr(chcode);
    inchar:=true;
    if ex<>0 then
      if chcode in [8,13,9,27] then
     begin
     ex:=chcode;
     inchar:=false;
     end;
    end;
end;{inchar}


procedure ReadAt(x,y,nchars:integer;var TheString:maxstring);
{Not Used here, but may be useful to other programs,
 performs read from video buffer}
Var
  i,j:integer;
  Attribute:Byte;

Begin{1}
TheString:='';
   j := 2*((y-1)*80+(x-1));{offset in video buffer}
   i:=1;
   While (i<=nchars) do
       begin{3}
       TheString:=TheString+chr(ord(Mem[VideoSeg:j]));
       i:=i+1;
       j:=j+2;
       end;{3}
end;{1 of ReadAt}


procedure WriteAt(x,y:integer;WriteMode:VideoMode;TheString:maxstring);
{Memory Mapped write}
Var
  i,j,k:integer;
  Attribute:Byte;

Begin{1}
  case WriteMode of {change these for color terminals}
   Norm:       Attribute := $07;
   Rev:        Attribute := $70;
   Hi:           Attribute := $0F;
   Und:        Attribute := $01;
   RevHi:      Attribute := $78;
   Blink:      Attribute := $87;
   BlinkHi:    Attribute := $8F;
   RevBlink:   Attribute := $F0;
   RevBlinkHi: Attribute := $F8;
   ELSE        Attribute := $07;{Normal}
   end;


   j := 2*((y-1)*80+(x-1));{offset in video buffer}
   i:=1;
   k:=length(thestring);
   While i<=k do
       begin
       Mem[VideoSeg : j] := Byte(TheString[i]);
       Mem[VideoSeg : (j+1)] := Attribute;
       i:=i+1;
       j:=j+2;
       end;
end;{1 of WriteAt}



Procedure LoadMenus(var MenuList:MenuAry);
{loads the menu data file}
var i,j,k:integer;
    f:text;
    s:maxstring;

Procedure GetAMenu(var M:MenuPtr);
label 99;
var i,j,k:integer;
begin
i:=-1;
j:=0;
{ s has been primed }
M^.MenuName:=s;
readln(f,s);
s:=s+'            ';
while (s[1]<>'*') and (not eof(f)) do
   begin

   if s[1]<>' ' then
     begin
     if i>=0 then M^.NumEntry[i]:=j;
     i:=i+1;
     M^.Menu[i,0]:=s;
     j:=0;
     end

   else
     if s[1]<>'*' then
       begin
       j:=j+1;
       delete(s,1,1);
       M^.Menu[i,j]:=s;
       end
     else goto 99;


  readln(f,s);
  s:=s+'            ';

  end;

99:
M^.NumEntry[i]:=j;
M^.NoItems:=i;

end;{GetAMenu}

begin{Load}

assign(f,'men2.dat'); {alter name for application}
reset(f);

i:=0;
readln(f,s);

while not eof(f) do
   begin
   i:=i+1;
   New(Menus[i]);
   GetAMenu(Menus[i]);
   end;
NumMenus:=i;

close(f);

{some other initialization here}

botbox:='╚';
for i:=1 to Width do botbox:=botbox+'═';
botbox:=botbox+'╝';

end;{LoadMenu}




procedure DoMenu(var itemsel,entrysel:integer;M:MenuPtr);

{this runs a menu, reads keys etc,}
{itemsel and entrysel are returned}


type
   setofkeys=set of 0..132;

var
   chc,ex:integer;
   ch:char;
   validkeys:setofkeys;
   asc,selection:boolean;
   item,entry:integer;
   s1,s2:maxstring;


Procedure PaintMenuBar;
var
i,sx:integer;
begin

clrscr;

writeat(1,1,rev,
'                                                                                ');
for i:=0 to M^.NoItems do
   begin
   sx:=2+i*Width;
   writeat(sx,1,rev,M^.Menu[i,0]);
   end;
end;{PaintMenuBar}


Procedure Bright(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
s:=M^.Menu[ix,ij];
sx:=ix*Width+1;
writeat(sx+1,ij+1,Rev,s)
end;



Procedure UnderScore(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
sx:=ix*Width+1;
s:=M^.Menu[ix,ij];
writeat(sx+1,ij+1,Und,s)
end;


Procedure Normal(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
sx:=ix*Width+1;
if ij=0 then if sx<1 then sx:=1;
s:=M^.Menu[ix,ij];
writeat(sx+1,ij+1,Norm,s);
end;



Procedure PushUp(ix:integer);
var sx,i:integer;
begin
sx:=ix*Width+1;
if sx<1 then sx:=1;
for i:=1 to M^.NumEntry[ix]+1 do
   writeat(sx,i+1,Norm,'             ');
end;

Procedure PullDown(ix:integer);
const

    l:maxstring='║';
    r:maxstring='║';
var sx:integer;
    s:maxstring;
    j:integer;
begin
sx:=ix*Width+1;
for j:=1 to M^.NumEntry[ix] do
    begin
    s:=l+M^.Menu[ix,j]+r;
    writeat(sx,j+1,Norm,s);
    end;
if M^.NumEntry[ix]>0 then writeat(sx,M^.NumEntry[ix]+2,Norm,botbox);
end;


begin {DoMenu}

CursorOff;

validkeys:=[13,15,75,9,77,80,72,27];

entry:=1;
item:=0;
PaintMenuBar;
PullDown(0);
Bright(item,entry);

selection:=FALSE;

while not selection do
   begin

   asc:= Inchar(ch,ex);

   if ex=0 then {Ctl-Brk hit}
      begin
      CursorNormal;
      clrscr;
      halt;
      end;

   if not asc then
   case ex{tended code} of

      13:{CR}
         selection:=TRUE;


      15, 75:{lefttab,left}
         if item>0 then
           begin
           item:=item-1;
           entry:=1;
           pushup(item+1);
           pulldown(item);
           Bright(item,entry);
           end;

       9, 77:{tab,right}
         if item<M^.NoItems then
           begin
           item:=item+1;
           entry:=1;
           pushup(item-1);
           pulldown(item);
           entry:=1;
           Bright(item,1);
           end;

      80:{down}
         begin
         if entry<M^.NumEntry[item] then
        begin
        entry:=entry+1;
        Normal(item,entry-1);
        Bright(item,entry);
        end
         else
           begin
           entry:=1;
           Normal(item,M^.NumEntry[item]);
           Bright(item,entry);
           end;
         end;

      72:{up}
         begin
         if entry>1 then
        begin
        entry:=entry-1;
        Normal(item,entry+1);
        Bright(item,entry);
        end
         else
           begin
           entry:=M^.NumEntry[item];
           Normal(item,1);
           Bright(item,entry);
           end;
         end;
      27:{Esc}
           begin
           selection:=TRUE;
           item:=0;
           entry:=0;
           end;

      end;{case}

   end;{while not selection}
itemsel:=item;
entrysel:=entry;

CursorNormal;

end;{DoMenu}



Procedure RunMenus;

{  Skeleton Procedure that you flesh out to run your menu tree.

   DoMenu returns item=menu bar item  and entry=entry underneath the
   item  as the selection. Zeros are returned for the escape key.

   Compose the CASE index by 100* Active + 10*Item + Entry .

    So Menu 2 Item 3 Entry 4 has an index of 234.

  Fill in the Case statement to accomodate the returned indices.

}

var
exit:boolean;
ch:char;
Active,index,item,entry:integer;

begin {RunMenu}

exit:=FALSE;
Active:=1;

while not exit do
  begin

  DoMenu(item,entry,Menus[Active]);

  index:=Active*100+item*10+entry;

  case index of {fill this in appropriately with structure}

  100:exit:=TRUE;

  101..104,201..204,301..304: begin
        gotoxy(10,10);
        writeln(' This is for Information Only');
        delay(5000);
        end;

  111 : begin
    Active:=2; {select next Menu}
    end;

  112 : begin
    Active:=3; {select next Menu}
    end;

  121,122,211,212 : begin
        gotoxy(10,10);
        writeln(' These Entries Have No Function.');
        delay(5000);
        end;


  131,222: begin
       gotoxy(10,10);
       write(' Do You Really Want to Quit? ');
       readln(ch);
       if ch in ['Y','y'] then exit:=TRUE;
       end;


  221,321,200,300:Active:=1;


  311:begin
       gotoxy(10,10);
       write(' Caesar slowly sipped his snifter,');
       writeln(' seized his knees and sneezed.');
       delay(5000);
       end;

   312:begin
       gotoxy(10,10);
       writeln(' Peter Piper picked a peck of pickled peppers.');
       delay(5000);
       end;
   end;{case}

  end;
end;{RunMenus}

begin{main}

CursorNormal;

SetVideoSeg;
LoadMenus(Menus);
RunMenus;
clrscr;
end.